home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / fngen.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  8KB  |  215 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30. ;;;
  31. ;;; GET-FUNCTION is the main user interface to this code. It is like
  32. ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by 
  33. ;;; reducing the number of times that the compiler needs to be called.  
  34. ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants 
  35. ;;; can use the same piece of compiled code.  (For example, dispatch dfuns and 
  36. ;;; combined method functions can often be shared, if they differ only 
  37. ;;; by referring to different methods.)
  38. ;;;
  39. ;;; If GET-FUNCTION is called with a lambda expression only, it will return 
  40. ;;; a corresponding function. The optional constant-converter argument
  41. ;;; can be a function which will be called to convert each constant appearing
  42. ;;; in the lambda to whatever value should appear in the function.
  43. ;;;
  44. ;;; There are three internal functions which operate on the lambda argument 
  45. ;;; to GET-FUNCTION:
  46. ;;;   compute-test converts the lambda into a key to be used for lookup,
  47. ;;;   compute-code is used by get-new-function-generator-internal to
  48. ;;;                generate the actual lambda to be compiled, and
  49. ;;;   compute-constants is used to generate the argument list that is
  50. ;;;                to be passed to the compiled function.
  51. ;;;
  52. ;;; Whether the returned function is actually compiled depends on whether
  53. ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
  54. ;;; code was precompiled.
  55. ;;; 
  56. (defun get-function (lambda
  57.               &optional (test-converter     #'default-test-converter)
  58.                         (code-converter     #'default-code-converter)
  59.                 (constant-converter #'default-constant-converter))
  60.   (function-apply (get-function-generator lambda test-converter code-converter)
  61.           (compute-constants      lambda constant-converter)))
  62.  
  63. (defun get-function1 (lambda
  64.               &optional (test-converter     #'default-test-converter)
  65.                         (code-converter     #'default-code-converter)
  66.                 (constant-converter #'default-constant-converter))
  67.   (values (the function (get-function-generator lambda test-converter code-converter))
  68.       (compute-constants      lambda constant-converter)))
  69.  
  70. (defun default-constantp (form)
  71.   (and (constantp form)
  72.        (not (typep (eval form) '(or symbol fixnum)))))
  73.  
  74. (defun default-test-converter (form)
  75.   (if (default-constantp form)
  76.       '.constant.
  77.       form))
  78.  
  79. (defun default-code-converter  (form)
  80.   (if (default-constantp form)
  81.       (let ((gensym (gensym))) (values gensym (list gensym)))
  82.       form))
  83.  
  84. (defun default-constant-converter (form)
  85.   (if (default-constantp form)
  86.       (list (eval form))
  87.       nil))
  88.  
  89.  
  90. ;;;
  91. ;;; *fgens* is a list of all the function generators we have so far.  Each 
  92. ;;; element is a FGEN structure as implemented below.  Don't ever touch this
  93. ;;; list by hand, use STORE-FGEN.
  94. ;;;
  95. (defvar *fgens* ())
  96.  
  97. (defun store-fgen (fgen)
  98.   (let ((old (lookup-fgen (fgen-test fgen))))
  99.     (if old
  100.     (setf (svref old 2) (fgen-generator fgen)
  101.           (svref old 4) (or (svref old 4)
  102.                 (fgen-system fgen)))
  103.     (setq *fgens* (nconc *fgens* (list fgen))))))
  104.  
  105. (defun lookup-fgen (test)
  106.   (find test (the list *fgens*) :key #'fgen-test :test #'equal))
  107.  
  108. (defun make-fgen (test gensyms generator generator-lambda system)
  109.   (let ((new (make-array 6)))
  110.     (setf (svref new 0) test
  111.       (svref new 1) gensyms
  112.       (svref new 2) generator
  113.       (svref new 3) generator-lambda
  114.       (svref new 4) system)
  115.     new))
  116.  
  117. (defun fgen-test             (fgen) (svref fgen 0))
  118. (defun fgen-gensyms          (fgen) (svref fgen 1))
  119. (defun fgen-generator        (fgen) (svref fgen 2))
  120. (defun fgen-generator-lambda (fgen) (svref fgen 3))
  121. (defun fgen-system           (fgen) (svref fgen 4))
  122.  
  123.  
  124.  
  125. (defun get-function-generator (lambda test-converter code-converter)
  126.   (let* ((test (compute-test lambda test-converter))
  127.      (fgen (lookup-fgen test)))
  128.     (if fgen
  129.     (fgen-generator fgen)
  130.     (get-new-function-generator lambda test code-converter))))
  131.  
  132. (defun get-new-function-generator (lambda test code-converter)
  133.   (multiple-value-bind (gensyms generator-lambda)
  134.       (get-new-function-generator-internal lambda code-converter)
  135.     (let* ((generator (compile-lambda generator-lambda))
  136.        (fgen (make-fgen test gensyms generator generator-lambda nil)))
  137.       (store-fgen fgen)
  138.       generator)))
  139.  
  140. (defun get-new-function-generator-internal (lambda code-converter)
  141.   (multiple-value-bind (code gensyms)
  142.       (compute-code lambda code-converter)
  143.     (values gensyms `(lambda ,gensyms (function ,code)))))
  144.  
  145.  
  146. (defun compute-test (lambda test-converter)
  147.   (let ((walk-form-expand-macros-p t))
  148.     (walk-form lambda
  149.            nil
  150.            #'(lambda (f c e)
  151.            (declare (ignore e))
  152.            (if (neq c :eval)
  153.                f
  154.                (let ((converted (funcall test-converter f)))
  155.              (values converted (neq converted f))))))))
  156.  
  157. (defun compute-code (lambda code-converter)
  158.   (let ((walk-form-expand-macros-p t)
  159.     (gensyms ()))
  160.     (values (walk-form lambda
  161.                nil
  162.                #'(lambda (f c e)
  163.                (declare (ignore e))
  164.                (if (neq c :eval)
  165.                    f
  166.                    (multiple-value-bind (converted gens)
  167.                    (funcall code-converter f)
  168.                  (when gens (setq gensyms (append gensyms gens)))
  169.                  (values converted (neq converted f))))))
  170.           gensyms)))
  171.  
  172. (defun compute-constants (lambda constant-converter)
  173.   (let ((walk-form-expand-macros-p t)) ; doesn't matter here.
  174.     (macrolet ((appending ()
  175.          `(let ((result ()))
  176.            (values #'(lambda (value) (setq result (append result value)))
  177.             #'(lambda ()result)))))
  178.       (gathering1 (appending)
  179.           (walk-form lambda
  180.                  nil
  181.                  #'(lambda (f c e)
  182.                  (declare (ignore e))
  183.                  (if (neq c :eval)
  184.                      f
  185.                      (let ((consts (funcall constant-converter f)))
  186.                        (if consts
  187.                        (progn (gather1 consts) (values f t))
  188.                        f)))))))))
  189.  
  190.  
  191. ;;;
  192. ;;;
  193. ;;;
  194. (defmacro precompile-function-generators (&optional system)
  195.   (let ((index -1))
  196.     `(progn ,@(gathering1 (collecting)
  197.         (dolist (fgen *fgens*)
  198.           (when (or (null (fgen-system fgen))
  199.                 (eq (fgen-system fgen) system))
  200.             (when system (setf (svref fgen 4) system))
  201.             (gather1
  202.              (make-top-level-form
  203.               `(precompile-function-generators ,system ,(incf index))
  204.               '(load)
  205.               `(load-function-generator
  206.             ',(fgen-test fgen)
  207.             ',(fgen-gensyms fgen)
  208.             (function ,(fgen-generator-lambda fgen))
  209.             ',(fgen-generator-lambda fgen)
  210.             ',system)))))))))
  211.  
  212. (defun load-function-generator (test gensyms generator generator-lambda system)
  213.   (store-fgen (make-fgen test gensyms generator generator-lambda system)))
  214.  
  215.